RSY -Mini Challenge 1
Librarys
#install.packages(c("vegan", 'coop', 'bench'))
library("reshape2")
library("recommenderlab")## Loading required package: Matrix## Loading required package: arules##
## Attaching package: 'arules'## The following objects are masked from 'package:base':
##
## abbreviate, write## Loading required package: proxy##
## Attaching package: 'proxy'## The following object is masked from 'package:Matrix':
##
## as.matrix## The following objects are masked from 'package:stats':
##
## as.dist, dist## The following object is masked from 'package:base':
##
## as.matrix## Loading required package: registry## Registered S3 methods overwritten by 'registry':
## method from
## print.registry_field proxy
## print.registry_entry proxylibrary("dplyr")##
## Attaching package: 'dplyr'## The following objects are masked from 'package:arules':
##
## intersect, recode, setdiff, setequal, union## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary("tidyr")##
## Attaching package: 'tidyr'## The following objects are masked from 'package:Matrix':
##
## expand, pack, unpack## The following object is masked from 'package:reshape2':
##
## smithslibrary("ggplot2")
library("vegan")## Loading required package: permute## Loading required package: lattice## This is vegan 2.5-7library("coop")
library("bench")
library("gridExtra")##
## Attaching package: 'gridExtra'## The following object is masked from 'package:dplyr':
##
## combinedata("MovieLense")
### use only users with more than 100 ratings
MovieLense100 <- MovieLense[rowCounts(MovieLense) >100,]
MovieLense100## 358 x 1664 rating matrix of class 'realRatingMatrix' with 73610 ratings.Explorative Datenanalyse
## Show rating of 5 users of 5 movies:
ml10 <- MovieLense[c(1:5),c(1:5)]
as(ml10, "matrix")## Toy Story (1995) GoldenEye (1995) Four Rooms (1995) Get Shorty (1995)
## 1 5 3 4 3
## 2 4 NA NA NA
## 3 NA NA NA NA
## 4 NA NA NA NA
## 5 4 3 NA NA
## Copycat (1995)
## 1 3
## 2 NA
## 3 NA
## 4 NA
## 5 NA# Create subsample to make the EDA run faster. Uncomment to activate!
# MovieLenseSample <- sample(x=MovieLense, size=500)
MovieLenseSample <- as(MovieLense, 'data.frame')
MovieLenseSample <- MovieLenseSample %>% rename(title = item)
MovieLenseSample# 1.Welches sind die am häufigsten geschauten Genres/Filme?
MostWatchedMovies <- MovieLenseSample %>% count(title, sort=TRUE)
MostWatchedMoviesMovie_Genre <- MovieLenseMeta %>%
pivot_longer(cols=c(unknown:Western)) %>%
filter(value==1) %>%
rename(genre = name)
MostWatchedGenres <- inner_join(MostWatchedMovies, Movie_Genre) %>%
count(genre, sort=TRUE)## Joining, by = "title"MostWatchedGenresBeschreibung
Dramas werden am meisten bewertet.
# 1.a.Wieviele Filme bewerten User
MoviesRatedPerUser <- MovieLenseSample %>% count(user, sort=TRUE)
MoviesRatedPerUsermean(MoviesRatedPerUser$n)## [1] 105.3998ggplot(MoviesRatedPerUser, aes(x=n)) +
geom_histogram(bins=30) +
ggtitle("Verteilungen Anzahl Bewertungen pro User. ") 
Beschreibung
Wir beobachten, dass nur wenige User über 400 Bewertungen abgegeben haben. Bei den meisten Usern sind es nur ein paar duzend Bewertungen und der Durchschnitt liegt etwa bei 100.
# 1.b. Anzahl Bewertungen pro Film
MoviesRatedPertitle <- MovieLenseSample %>% count(title, sort=TRUE)
MoviesRatedPertitlemean(MoviesRatedPertitle$n)## [1] 59.73077ggplot(MoviesRatedPertitle, aes(x=n)) +
geom_histogram(bins=30) +
ggtitle("Verteilungen Anzahl Bewertungen pro Film. ") 
Beschreibung
Wir sehen hier eine ähnliche Verteilung: Es gibt ca. 100 Filme mit sehr vielen Bewertungen (50+), aber die meisten Filme haben wenige bis gar keine Bewertungen.
# 2.Wie verteilen sich die Kundenratings gesamthaft und nach Genres?
ggplot(MovieLenseSample, aes(x=rating)) +
geom_bar() +
ggtitle(paste("Kundenratings gesamthaft. Durchschnitt: ", round(mean(MovieLenseSample$rating),2)))
# grouped boxplot
MovieLenseSample_genre <- inner_join(MovieLenseSample, Movie_Genre)## Joining, by = "title"MovieLenseSample_genre_mean <- MovieLenseSample_genre %>%
group_by(genre) %>%
summarise(mean = mean(rating)) %>%
select(genre, mean) %>%
arrange(desc(mean))
MovieLenseSample_genre_meanggplot(MovieLenseSample_genre, aes(x=rating, fill=genre)) +
geom_bar(mapping = aes(x = rating)) +
facet_wrap(~ genre)
Beschreibung
Das Muster der Bewertungen von unterschiedlichen Genres ist sehr ähnlich. Die meisten Bewertungen liegen zwischen 3 und 4. Zudem gibt es starke schwankungen bei der Anzahl der Bewertungen der jeweiligen Genres. Dies macht es schwieriger sie grafisch zu vergleichen.
# 3.Wie verteilen sich die mittleren Kundenratings pro Film?
rating_mean <- MovieLenseSample %>%
group_by(title) %>%
summarise(mean = mean(rating)) %>%
select(title, mean) %>%
arrange(desc(mean))
rating_meanggplot(rating_mean, aes(x=mean)) +
geom_histogram(binwidth=0.1) +
ggtitle("Verteilung der durchschnittlichen Kundenratings") +
geom_vline(aes(xintercept=mean(mean)),
color="blue", linetype="dashed", size=1) +
xlab("Rating") + ylab("Anzahl")
Beschreibung
Wir sehen anhand der Grafik zwei Auffälligkeiten: Einen starken Peak bei der Bewertung 1 und 5. Unsere Vermutung ist es, dass es Users sind die nur eine Bewertung abgegeben haben.
summary(rating_mean)## title mean
## Length:1664 Min. :1.000
## Class :character 1st Qu.:2.665
## Mode :character Median :3.162
## Mean :3.077
## 3rd Qu.:3.653
## Max. :5.000# 4.Wie stark streuen die Ratings von individuellen Kunden?
rating_std<- MovieLenseSample %>%
group_by(user) %>%
summarise(std = sd(rating)) %>%
select(user, std) %>%
arrange(desc(std))
rating_stdsummary(rating_std)## user std
## Length:943 Min. :0.3444
## Class :character 1st Qu.:0.8757
## Mode :character Median :1.0116
## Mean :1.0196
## 3rd Qu.:1.1415
## Max. :1.7499ggplot(rating_std, aes(x=std)) +
geom_histogram(binwidth=0.1) +
ggtitle("Streuung der Ratings von inviduellen Kunden") +
geom_vline(aes(xintercept=mean(std)),
color="blue", linetype="dashed", size=1)
Beschreibung
Eine Normalverteilung bei der Streuung des Ratings der individuellen Kunden. Auf der X-Achse sehen wir den Wert der Standardabweichung und auf der Y-Achse die Anzahl von Standardabweichungen, welche in den spezifischen Säulen fallen. Somit sehen wir, dass die Streuung von inviduellen Kunden am meisten mit einer Standardabweichung von 1 streuuen.
summary(rating_std)## user std
## Length:943 Min. :0.3444
## Class :character 1st Qu.:0.8757
## Mode :character Median :1.0116
## Mean :1.0196
## 3rd Qu.:1.1415
## Max. :1.7499# 5.Welchen Einfluss hat die Normierung der Ratings pro Kunde auf deren Verteilung?
norm_rating_mean <- recommenderlab::normalize(MovieLense, method='center')
norm_rating_mean <- as(norm_rating_mean, 'data.frame')
ggplot(norm_rating_mean, aes(x=rating)) +
geom_histogram(binwidth=0.1) +
ggtitle("Streuung der normierten Ratings von inviduellen Kunden nach method 'center'") +
geom_vline(aes(xintercept=mean(rating)),
color="blue", linetype="dashed", size=1)
norm_rating_mean <- recommenderlab::normalize(MovieLense, method='Z-score')
norm_rating_mean <- as(norm_rating_mean, 'data.frame')
ggplot(norm_rating_mean, aes(x=rating)) +
geom_histogram(binwidth=0.1) +
ggtitle("Streuung der normierten Ratings von inviduellen Kunden nach method 'Z-score'") +
geom_vline(aes(xintercept=mean(rating)),
color="blue", linetype="dashed", size=1)
Beschreibung
Auch hier sehen wir wieder die Streuung der Ratings von den individuellen Kunden, aber diesmal wurden zwei verschiedene Normierungen durchgeführt. Durch die Normalisierung versucht man die Verzerrung der einzelnen Ratings zu verringern. Die Daten werden zeilenweise zentriert. Das heisst, dass von jedem Rating der Mittelwert der Ratings des jeweilig betreffenden Users abgezogen wird. Der Z-Score wird zusätzlich durch die Standardabweichung der Zeile/Reihe dividiert. (Hahsler 2013, p.17, http://www2.uaem.mx/r-mirror/web/packages/recommenderlab/recommenderlab.pdf)
MovieLense## 943 x 1664 rating matrix of class 'realRatingMatrix' with 99392 ratings.norm_rating_mean <- recommenderlab::normalize(MovieLense)
norm_rating_mean <- as(norm_rating_mean, 'data.frame')
norm_rating_meanBeschreibung
Bei beiden Methoden werden die Ratings zentiert, also das der Durchschnitt 0 wird. Bei der Normierung “Z-Score” wird noch zusätzlich durch die Standardabweichung geteilt, damit die Verteilung dann einen Durchschnitt von 0 hat und eine Standardabweichung von 1 hat.
# 6.Welche strukturellen Charakteristika (z.B. Sparsity) und Auffälligkeiten zeigt die User-Item Matrix?
image(MovieLense)
Beschreibung
Man sieht klare Muster: z.B. gibt es Filme, welche sehr selten gerated wurden (vertikale, weisse Linie) und User, welche sehr selten raten (horizontale, weisse Linie). Zusätzlich gibt es “oben rechts” sehr viel “nichts”. Es scheint aber so, als entsteht dies durch die Funktion “image” von recommenderlab. Leider gibt es nicht genügend Dokumentationen um mehr drüber zu erfahren, warum das entsteht. Es scheint einfach nach etwas bestimmten sortiert zu sein.
Aufgabe Seite 7
Aufgabe: Reduziere den MovieLense Datensatz auf rund 400 Kunden und 700 Filme, indem du Filme und Kunden mit sehr wenigen Ratings entfernst. Untersuche und dokumentiere die Eigenschaften des reduzierten Datensatzes und beschreibe den Effekt der Datenreduktion:
- Anzahl Filme und Kunden sowie Sparsity vor und nach Datenreduktion,
- mittlere Kundenratings pro Film vor und nach Datenreduktion.
data(MovieLense)
MovieLense_df <- as(MovieLense, "data.frame")
MovieLenseMeta_df <- as(MovieLenseMeta, "data.frame")
MOVIE_MIN_RATED = 700
USER_MIN_RATED = 400
SEED = 42
####
# Calculate reduced Dataset.
set.seed(4)
movies_min_rated <- MovieLense_df %>%
count(item) %>%
arrange(desc(n)) %>%
head(MOVIE_MIN_RATED) %>%
select(item)
MovieLense_user_movies_reduced_df <- MovieLense_df %>%
inner_join(movies_min_rated, by='item')
user_min_movies_rated <- MovieLense_user_movies_reduced_df %>%
count(user) %>%
arrange(desc(n)) %>%
head(USER_MIN_RATED) %>%
select(user)
MovieLense_user_movies_reduced_df <- MovieLense_user_movies_reduced_df %>%
inner_join(user_min_movies_rated, by='user')
# Calculate Random Dataset.
random_users <- sample(x = unique(MovieLense_df$user), size = USER_MIN_RATED)
Movies_user_random_selected_df <- MovieLense_df %>%
dplyr::filter(user %in% random_users)
random_movie_names <- sample(x = unique(Movies_user_random_selected_df$item), size = MOVIE_MIN_RATED)
Movies_random_selected_df <- Movies_user_random_selected_df %>%
dplyr::filter(item %in% random_movie_names)
user_min_movies_rated <- Movies_user_random_selected_df %>%
count(item) %>%
arrange(desc(n)) %>%
head(MOVIE_MIN_RATED) %>%
select(item)
MoviesLense_random_user_top_movies_df <- Movies_user_random_selected_df %>%
inner_join(user_min_movies_rated, by='item')
# Normaized Ratings
MovieLense_norm <- recommenderlab::normalize(MovieLense)
MovieLense_reduced_norm <- recommenderlab::normalize(as(MovieLense_user_movies_reduced_df, class(MovieLense)))
MovieLense_random_norm <- recommenderlab::normalize(as(Movies_random_selected_df, class(MovieLense)))
MovieLense_random_user_top_movie_norm <- recommenderlab::normalize(as(MoviesLense_random_user_top_movies_df, class(MovieLense)))
### Sparsity
# Not Normalized
plot_rows = 50
image(MovieLense[1:plot_rows, 1:plot_rows], main = "Ratings Snippet: ALL")
image(as(MovieLense_user_movies_reduced_df, class(MovieLense))[1:plot_rows, 1:plot_rows], main = "Ratings Snippet: Reduced")
image(as(Movies_random_selected_df, class(MovieLense))[1:plot_rows, 1:plot_rows], main = "Ratings Snippet: Random")
image(as(MoviesLense_random_user_top_movies_df, class(MovieLense))[1:plot_rows, 1:plot_rows], main = "Ratings Snippet: Random User, Top Movies")
# Normalized Ratings
image(MovieLense_norm[1:plot_rows, 1:plot_rows], main = "Normalized Ratings Snippet: ALL")
image(MovieLense_reduced_norm[1:plot_rows, 1:plot_rows], main = "Normalized Ratings Snippet: Reduced")
image(MovieLense_random_norm[1:plot_rows, 1:plot_rows], main = "Normalized Ratings Snippet: Random")
image(MovieLense_random_user_top_movie_norm[1:plot_rows, 1:plot_rows], main = "Normalized Ratings Snippet: Random User, Top Movies")
Beschreibung:
Wir sehen, dass die Sparsity bei der Random-selection ca. gleich bleibt. Dagegen ist, wenn man Filme und User mit wenig Bewertungen weglässt, ist die Sparsity voller.
calc_sparsity <- function(RRM){
density_ = nratings(RRM) / (nrow(RRM)*ncol(RRM))
return (1 - density_)
}
intersect_over_union <- function(mat1, mat2){
sparsity_iou <- calc_sparsity(mat1==mat2)
return (sparsity_iou)
}
full_spars = calc_sparsity(as(MovieLense_df, class(MovieLense)))
reduced_spars = calc_sparsity(as(MovieLense_user_movies_reduced_df, class(MovieLense)))
rand_spars = calc_sparsity(as(Movies_random_selected_df, class(MovieLense)))
rand_top_movies_spars = calc_sparsity(as(MoviesLense_random_user_top_movies_df, class(MovieLense)))
all_spars = c(full_spars, reduced_spars, rand_spars, rand_top_movies_spars)
spars_name = c('Full Matrix', 'Reduced Matrix', 'Random Matrix', 'Random User, Top Movies Matrix')
ggplot(mapping=aes(spars_name, all_spars)) +
geom_col(fill = "grey", color="black") +
ggtitle(paste("Sparsity der verschiedenen Matrizen")) +
xlab("") + ylab("Sparse Elements / All Elements ")
Beschreibung:
In der Grafik sehen wir hier die unterschiedlichen Matrizen (Datensätze) die wir miteinander vergleichen werden. Die Sparsity von der zufällig reduzierten Matrix (Random Matrix) ist ähnlich wie der von der ganzen Matrix (Full Matrix). Diese Beobachtung macht auch Sinn, da die Auswahl der Datenpunkte zufällig gewählt worden ist. Hingegen bei der reduzierten Matrix (Reduced Matrix) wo wir darauf geachtet haben, dass wir User und Filme mit wenig Ratings entfernen, ist die Sparsity deutlich tiefer.
plot_rating_mean <- function(data, plot_title){
# Extracts rating means by grouping values
rating_mean <- data %>%
group_by(item) %>%
summarise(mean = mean(rating)) %>%
select(item, mean) %>%
arrange(desc(mean))
r_plot <- ggplot(rating_mean, aes(x=mean)) +
geom_density(fill="grey") +
ggtitle(plot_title) +
geom_vline(aes(xintercept=mean(mean)),
color="black", linetype="dashed", size=1) +
xlab("Mean Ratings")
return(r_plot)
}
# Plot data
p1 <- plot_rating_mean(data = as(MovieLense, class(data.frame())), plot_title = "ALL")
p2 <- plot_rating_mean(data = MovieLense_user_movies_reduced_df, plot_title = "Reduced")
p3 <- plot_rating_mean(data = Movies_random_selected_df, plot_title = "Random")
grid.arrange(p1, p2, p3, ncol=1, nrow=3, top = "Unnormalized Mean Ratings")
# Plot normalized ratings
p1 <- plot_rating_mean(data = as(MovieLense_norm, "data.frame"), plot_title = "ALL")
p2 <- plot_rating_mean(data = as(MovieLense_reduced_norm, "data.frame"), plot_title = "Reduced")
p3 <- plot_rating_mean(data = as(MovieLense_random_norm, "data.frame"), plot_title = "Random")
grid.arrange(p1, p2, p3, ncol=1, nrow=3, top="Normalized Mean Ratings")
Beschreibung:
Wenn wir die Kundenratings pro Film vor und nach Datenreduktion betrachten, können wir sehen, dass bei der reduzierten Matrix wo Users mehr Ratings abgegeben haben, eher besser bewerten. Eine Ursache dafür können wir auch direkt aus der Grafik lesen: Fast alle User, die einen Durchschnittsrating von 1 haben fallen weg.
Aufgabe Seite 8
Aufgabe: Erzeuge einen IBCF Recommender und analysiere die Ähnlichkeitsmatrix des trainierten Modelles für den reduzierten Datensatz.
- Zerlege den reduzierten MovieLense Datensatz in ein disjunktes Trainingsund Testdatenset im Verhältnis 4:1,
- Trainiere ein IBCF Modell mit 30 Nachbarn und Cosine Similarity,
- Bestimme die Verteilung der Filme, welche bei IBCF für paarweise Ähnlichkeitsvergleiche verwendet werden,
- Bestimme die Filme, die am häufigsten in der Cosine-Ähnlichkeitsmatrix auftauchen und analysiere deren Vorkommen und Ratings im reduzierten Datensatz.
# Konvertieren in RealRatingmatrizen
Movies_reduced <- coerce(MovieLense_user_movies_reduced_df, MovieLense)## Warning in coerce(MovieLense_user_movies_reduced_df, MovieLense): direct use of
## coerce() is deprecated: use as(from, class(to)) insteadMovies_random <- coerce(Movies_random_selected_df, MovieLense)## Warning in coerce(Movies_random_selected_df, MovieLense): direct use of coerce()
## is deprecated: use as(from, class(to)) insteadMovies_top_movies <- coerce(MoviesLense_random_user_top_movies_df, MovieLense)## Warning in coerce(MoviesLense_random_user_top_movies_df, MovieLense): direct use
## of coerce() is deprecated: use as(from, class(to)) insteadgiven_ratings_in_cv <- 10
goodRating_threshold <- 3
eval_random <- recommenderlab::evaluationScheme(data = as(Movies_random_selected_df, class(MovieLense)),
method="split", train=0.8, given=3)
eval_random_norm <- recommenderlab::evaluationScheme(data = MovieLense_random_norm,
method="split", train=0.8, given=3)
eval_reduced <- recommenderlab::evaluationScheme(data = as(MovieLense_user_movies_reduced_df, class(MovieLense)),
method="split", train=0.8, given=3)
eval_explicit <- recommenderlab::evaluationScheme(data = Movies_reduced,
method="cross-validation" , train=80,
k=10, given=given_ratings_in_cv,
goodRating=goodRating_threshold)
eval_reduced_norm <- recommenderlab::evaluationScheme(data = MovieLense_reduced_norm,
method="split", train=0.8, given=3)
eval_random_user_top_movies <- recommenderlab::evaluationScheme(data = as(MoviesLense_random_user_top_movies_df, class(MovieLense)),
method="split", train=0.8, given=3)
eval_random_user_top_movies_norm <- recommenderlab::evaluationScheme(data = MovieLense_random_user_top_movie_norm,
method="split", train=0.8, given=3)
IBCF_random <- Recommender(data = getData(eval_random, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))
IBCF_random_norm <- Recommender(data = getData(eval_random_norm, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))## Warning in .local(x, ...): x was already normalized by row!IBCF_reduced <- Recommender(data = getData(eval_reduced, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))
IBCF_reduced_norm <- Recommender(data = getData(eval_reduced_norm, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))## Warning in .local(x, ...): x was already normalized by row!IBCF_random_user_top_movies <- Recommender(data = getData(eval_random_user_top_movies, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))
IBCF_random_user_top_movies_norm <- Recommender(data = getData(eval_random_user_top_movies_norm, "train"), method = "IBCF",
parameter = list(k = 30, method = "Cosine", na_as_zero=FALSE))## Warning in .local(x, ...): x was already normalized by row!similarity_mat <- as.matrix(IBCF_reduced@model$sim)
similarity_mat = data.frame(similarity_mat)
similarity_mat[similarity_mat < 0.0000001] <- NA # Damit die Zahlen mit einer similarity von 0 nicht den ganzen Plot verziehen.
similarity_matplot_similarity_matrix <- function(Rec_Model, title, ignore_zeros=TRUE){
similarity_mat <- as.matrix(Rec_Model@model$sim)
similarity_mat <- data.frame(similarity_mat)
similarity_mat[similarity_mat == 0.0] <- NA
similarity_mat <- as.matrix(similarity_mat)
p <- ggplot(mapping = aes(x=similarity_mat)) +
geom_histogram(fill="grey", na.rm=TRUE,binwidth=0.05) + labs(title=title) + xlab("Cosine-Aehnlichkeit")
return (p)
}
p1 <- plot_similarity_matrix(IBCF_random, 'Verteilung Aehnlichkeiten random Datensatz')
p2 <- plot_similarity_matrix(IBCF_random_norm, 'Verteilung Aehnlichkeiten random, normierter Datensatz')
p3 <- plot_similarity_matrix(IBCF_reduced, 'Verteilung Aehnlichkeiten reduzierter Datensatz')
p4 <- plot_similarity_matrix(IBCF_reduced_norm, 'Verteilung Aehnlichkeiten reduzierter, normierter Datensatz')
p5 <- plot_similarity_matrix(IBCF_random_user_top_movies, 'Verteilung Aehnlichkeiten random user, top movies Datensatz')
p6 <- plot_similarity_matrix(IBCF_random_user_top_movies_norm, 'Verteilung Aehnlichkeiten random user, top movies normiert Datensatz')
p1
p2
p3
p4
p5
p6
Beschreibung:
Wenn wir die Vereitlung der Cosine-Ähnlichkeiten der verschiedenen Datensätze betrachten, sticht uns der extreme Spike bei 1 in jedem Histogramm ins Auge. Dies ist zurückzuführen, dass das die diagonalen Werte der Matrizen sind. Bei dem reduzierten Datensatz können wir die Verteilung der Filme bei einer Cosine-Ähnlichkeit um 0.6 herum entdecken.
Aufgabe Seite 9
Aufgabe: Vergleiche und diskutiere Top-N Empfehlungen von IBCF und UBCF Modellen mit 30 Nachbarn und Cosine Similarity für den reduzierten Datensatz. 1. Berechne Top-15 Empfehlungen für Testkunden mit IBCF und UBCF, 2. Vergleiche die Top-15 Empfehlungen und deren Verteilung und diskutiere Gemeinsamkeiten und Unterschiede zwischen IBCF und UBCF für alle Testkunden.
NUM_RECOMMENDATIONS = 15
####
Recommender_model_IBCF <- Recommender(data = getData(eval_reduced, "train"), method = "IBCF", parameter = list(method = "Cosine"))
Recommender_model_UBCF <- Recommender(data = getData(eval_reduced, "train"), method = "UBCF", parameter = list(method = "Cosine"))
Pred_IBCF <- predict(object = Recommender_model_IBCF, newdata = getData(eval_reduced, "unknown"), n = NUM_RECOMMENDATIONS)
Pred_UBCF <- predict(object = Recommender_model_UBCF, newdata = getData(eval_reduced, "unknown"), n = NUM_RECOMMENDATIONS)
###
Pred_UBCF_df <- data.frame(user = sort(rep(1:length(Pred_UBCF@items), Pred_UBCF@n)),
rating = unlist(Pred_UBCF@ratings), index = unlist(Pred_UBCF@items))
Pred_IBCF_df <- data.frame(user = sort(rep(1:length(Pred_IBCF@items), Pred_IBCF@n)),
rating = unlist(Pred_IBCF@ratings), index = unlist(Pred_IBCF@items))
Pred_IBCF_df$title <- Pred_IBCF@itemLabels[Pred_IBCF_df$index]
Pred_IBCF_df$year <- MovieLenseMeta$year[Pred_IBCF_df$index]
Pred_IBCF_dfPred_UBCF_df$title <- Pred_UBCF@itemLabels[Pred_UBCF_df$index]
Pred_UBCF_df$year <- MovieLenseMeta$year[Pred_UBCF_df$index]
Pred_UBCF_dfMovieLenseMeta_dfAufgabe Seite 10
Untersuche den Einfluss von Ratings (ordinale vs binäre Ratings) und Modelltyp (IBCF vs UBCF) auf Top-N Empfehlungen für den reduzierten Datensatz. 1.Vergleiche den Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs UBCF, beide mit ordinalem Rating und Cosine Similarity für alle Testkunden, 2.Vergleiche den Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs UBCF, beide mit binärem Rating und Jaccard Similarity für alle Testkunden, 3.Vergleiche den Anteil übereinstimmender Empfehlungen der Top-15 Liste für UBCF mit ordinalem (Cosine Similarity) vs binärem Rating (Jaccard Similarity) für alle Testkunden.
Recommender_model_IBCF_cosine <- Recommender(data = getData(eval_reduced, "train"), method = "IBCF", parameter = list(method = "Cosine",k=30))
Recommender_model_UBCF_cosine <- Recommender(data = getData(eval_reduced, "train"), method = "UBCF", parameter = list(method = "Cosine",nn=30))
reduced_binär <- binarize(getData(eval_reduced, "train"), minRating=2)
Recommender_model_IBCF_jaccard <- Recommender(data = getData(eval_reduced, "train"), method='IBCF', parameter=list(method='Jaccard',k=30))
Recommender_model_UBCF_jaccard <- Recommender(data = getData(eval_reduced, "train"), method='UBCF', parameter=list(method='Jaccard',nn=30))NUM_RECOMMENDATIONS <- 15
Recommender_model_IBCF_cosine_top15 <- predict(Recommender_model_IBCF_cosine, newdata=getData(eval_explicit, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_UBCF_cosine_top15 <- predict(Recommender_model_UBCF_cosine, newdata=getData(eval_explicit, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_IBCF_jaccard_top15 <- predict(Recommender_model_IBCF_jaccard, newdata=getData(eval_explicit, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_UBCF_jaccard_top15 <- predict(Recommender_model_UBCF_jaccard, newdata=getData(eval_explicit, "unknown"), n=NUM_RECOMMENDATIONS)Recommender_model_IBCF_cosine_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_IBCF_cosine_top15@items),
Recommender_model_IBCF_cosine_top15@n)),
rating = unlist(Recommender_model_IBCF_cosine_top15@ratings),
index = unlist(Recommender_model_IBCF_cosine_top15@items))
Recommender_model_UBCF_cosine_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_UBCF_cosine_top15@items),
Recommender_model_UBCF_cosine_top15@n)),
rating = unlist(Recommender_model_UBCF_cosine_top15@ratings),
index = unlist(Recommender_model_UBCF_cosine_top15@items))
Recommender_model_IBCF_jaccard_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_IBCF_jaccard_top15@items),
Recommender_model_IBCF_jaccard_top15@n)),
rating = unlist(Recommender_model_IBCF_jaccard_top15@ratings),
index = unlist(Recommender_model_IBCF_jaccard_top15@items))
Recommender_model_UBCF_jaccard_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_UBCF_jaccard_top15@items),
Recommender_model_UBCF_jaccard_top15@n)),
rating = unlist(Recommender_model_UBCF_jaccard_top15@ratings),
index = unlist(Recommender_model_UBCF_jaccard_top15@items))similarity_cosine = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_UBCF_cosine_top15_pred[Recommender_model_UBCF_cosine_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_cosine <- append(similarity_cosine,tt)
}
summary(similarity_cosine)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00000 0.00000 0.03333 0.04833 0.06667 0.33333similarity_cosine## [1] 0.06666667 0.13333333 0.06666667 0.00000000 0.13333333 0.00000000
## [7] 0.06666667 0.06666667 0.06666667 0.06666667 0.06666667 0.13333333
## [13] 0.06666667 0.00000000 0.00000000 0.06666667 0.00000000 0.00000000
## [19] 0.00000000 0.00000000 0.13333333 0.06666667 0.00000000 0.00000000
## [25] 0.00000000 0.00000000 0.00000000 0.06666667 0.00000000 0.00000000
## [31] 0.13333333 0.00000000 0.06666667 0.06666667 0.06666667 0.00000000
## [37] 0.00000000 0.33333333 0.00000000 0.00000000ggplot(mapping = aes(x=similarity_cosine)) +
geom_histogram(fill="grey", na.rm=TRUE,bins = 10) +
ggtitle(paste("Prozentuale Top@N Übereinstimmungen für IBCF vs UBCF mit Cosine Similarity"))+
xlab("Übereinstimmung")
Beschreibung:
In der Grafik sehen wir die Verteilung der Übereinstimmungen für IBCF vs UBCF mit ordinalem Rating und Cosine Similarity für alle Testkunden. Wir können feststellen, dass bei den meisten Usern keine bis ganz wenige Übereinstimmungen haben. Bei einem User haben wir eine Übereinstimmung von 40%, was sehr hoch ist. Dies bedeutet das von 15 Filmen davon 6 in beiden Listen vorkommt.
similarity_jaccard = c()
for (user in unique(Recommender_model_IBCF_jaccard_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_jaccard_top15_pred[Recommender_model_IBCF_jaccard_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_UBCF_jaccard_top15_pred[Recommender_model_UBCF_jaccard_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_jaccard <- append(similarity_jaccard,tt)
}
summary(similarity_jaccard)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.0000 0.0000 0.0000 0.0100 0.0000 0.1333similarity_jaccard## [1] 0.00000000 0.00000000 0.00000000 0.06666667 0.00000000 0.00000000
## [7] 0.00000000 0.00000000 0.13333333 0.00000000 0.00000000 0.00000000
## [13] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
## [19] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
## [25] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
## [31] 0.06666667 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
## [37] 0.00000000 0.00000000 0.13333333 0.00000000ggplot(mapping = aes(x=similarity_jaccard)) +
geom_histogram(fill="grey", na.rm=TRUE,bins = 10) +
ggtitle(paste("Prozentuale Top@N Übereinstimmungen für IBCF vs UBCF mit Jaccard Similarity"))+
xlab("Übereinstimmung")
Beschreibung:
In dieser Grafik sehen wir die Verteilung der Übereinstimmungen für IBCF vs UBCF mit diesmal binärem Rating und Jaccard Similarity für alle Testkunden. Hier sehen wir sofort, dass wir eine viel schwächere Übereinstimmung haben als mit der Cosine Similarity. Fast alle User haben keine Übereinstimmungen. Nur 2 User haben eine Übereinstimmung von 6.6% (1 Film) und 2 User eine Übereinstimmung von 13.3% (2 Filme).
similarity_UBCF = c()
for (user in unique(Recommender_model_UBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_UBCF_cosine_top15_pred[Recommender_model_UBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_UBCF_jaccard_top15_pred[Recommender_model_UBCF_jaccard_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_UBCF <- append(similarity_UBCF,tt)
}
summary(similarity_UBCF)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.00000 0.06667 0.06667 0.10333 0.13333 0.26667similarity_UBCF## [1] 0.06666667 0.20000000 0.00000000 0.26666667 0.20000000 0.06666667
## [7] 0.06666667 0.00000000 0.06666667 0.06666667 0.06666667 0.13333333
## [13] 0.13333333 0.00000000 0.06666667 0.06666667 0.13333333 0.06666667
## [19] 0.06666667 0.06666667 0.20000000 0.13333333 0.06666667 0.20000000
## [25] 0.13333333 0.06666667 0.06666667 0.20000000 0.06666667 0.20000000
## [31] 0.26666667 0.06666667 0.00000000 0.06666667 0.06666667 0.13333333
## [37] 0.13333333 0.13333333 0.06666667 0.06666667ggplot(mapping = aes(x=similarity_UBCF)) +
geom_histogram(fill="grey", na.rm=TRUE,bins = 10) +
ggtitle(paste("Prozentuale Top@N Übereinstimmungen UBCF mit Cosine Similarity und Jaccard Similarity")) +
xlab("Übereinstimmung")
Beschreibung:
In dieser Grafik vergleichen wir jetzt die Übereinstimmungen für UBCF mit ordinalem (Cosine Similarity) vs binärem Rating (Jaccard Similarity) für alle Testkunden. Hier können wir sagen, dass wir generellviele Übereinstimmungen haben. Nur 4 User haben gar keine Übereinstimmung.
means <- c(mean(similarity_cosine),mean(similarity_jaccard),mean(similarity_UBCF))
barplot(means, main="Vergleich der einzelnen Similaritys",names.arg=c("similarity cosine\nIBCF vs UBCF","similarity jaccard\nIBCF vs UBCF","similarity UBCF\ncosine vs jaccard"),
ylab="Mean")
Beschreibung:
Ein kurzer Vergleich der verschiedenen Similaritys die wir in dieser Aufgabe angeschaut haben.
Aufgabe Seite 11
Aufgabe: Vergleiche Memory-based IBCF und Modell-based SVD Recommenders bezüglich Überschneidung ihrer Top-N Empfehlungen für die User-Item Matrix des reduzierten Datensatzes (Basis: IBCF mit 30 Nachbarn und Cosine Similarity). 1.Vergleiche wie sich der Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF vs verschiedene SVD Modelle verändert, wenn die Anzahl der Singulärwerte für SVD von 10 auf 20, 30, 40, 50 verändert wird.
Recommender_model_SVD_10 <- Recommender(data = getData(eval_reduced, "train"), method = "SVD", parameter = list(k = 10))
Recommender_model_SVD_20 <- Recommender(data = getData(eval_reduced, "train"), method = "SVD", parameter = list(k = 20))
Recommender_model_SVD_30 <- Recommender(data = getData(eval_reduced, "train"), method = "SVD", parameter = list(k = 30))
Recommender_model_SVD_40 <- Recommender(data = getData(eval_reduced, "train"), method = "SVD", parameter = list(k = 40))
Recommender_model_SVD_50 <- Recommender(data = getData(eval_reduced, "train"), method = "SVD", parameter = list(k = 50))
NUM_RECOMMENDATIONS <- 15
Recommender_model_SVD_10_top15 <- predict(Recommender_model_SVD_10, newdata=getData(eval_reduced, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_SVD_20_top15 <- predict(Recommender_model_SVD_20, newdata=getData(eval_reduced, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_SVD_30_top15 <- predict(Recommender_model_SVD_30, newdata=getData(eval_reduced, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_SVD_40_top15 <- predict(Recommender_model_SVD_40, newdata=getData(eval_reduced, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_SVD_50_top15 <- predict(Recommender_model_SVD_50, newdata=getData(eval_reduced, "unknown"), n=NUM_RECOMMENDATIONS)
Recommender_model_SVD_10_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_SVD_10_top15@items),Recommender_model_SVD_10_top15@n)),
rating = unlist(Recommender_model_SVD_10_top15@ratings),index = unlist(Recommender_model_SVD_10_top15@items))
Recommender_model_SVD_20_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_SVD_20_top15@items),Recommender_model_SVD_20_top15@n)),
rating = unlist(Recommender_model_SVD_20_top15@ratings),index = unlist(Recommender_model_SVD_20_top15@items))
Recommender_model_SVD_30_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_SVD_30_top15@items),Recommender_model_SVD_30_top15@n)),
rating = unlist(Recommender_model_SVD_30_top15@ratings),index = unlist(Recommender_model_SVD_30_top15@items))
Recommender_model_SVD_40_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_SVD_40_top15@items),Recommender_model_SVD_40_top15@n)),
rating = unlist(Recommender_model_SVD_40_top15@ratings),index = unlist(Recommender_model_SVD_40_top15@items))
Recommender_model_SVD_50_top15_pred <- data.frame(user = sort(rep(1:length(Recommender_model_SVD_50_top15@items),Recommender_model_SVD_50_top15@n)),
rating = unlist(Recommender_model_SVD_50_top15@ratings),index = unlist(Recommender_model_SVD_50_top15@items))similarity_SVD_10 = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_SVD_10_top15_pred[Recommender_model_SVD_10_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_SVD_10 <- append(similarity_SVD_10,tt)}
similarity_SVD_20 = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_SVD_20_top15_pred[Recommender_model_SVD_20_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_SVD_20 <- append(similarity_SVD_20,tt)}
similarity_SVD_30 = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_SVD_30_top15_pred[Recommender_model_SVD_30_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_SVD_30 <- append(similarity_SVD_30,tt)}
similarity_SVD_40 = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_SVD_40_top15_pred[Recommender_model_SVD_40_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_SVD_40 <- append(similarity_SVD_40,tt)}
similarity_SVD_50 = c()
for (user in unique(Recommender_model_IBCF_cosine_top15_pred$user)) {
top_n_user_1 <- Recommender_model_IBCF_cosine_top15_pred[Recommender_model_IBCF_cosine_top15_pred$user == user,"index"]
top_n_user_2 <- Recommender_model_SVD_50_top15_pred[Recommender_model_SVD_50_top15_pred$user == user,"index"]
tt <- length(intersect(top_n_user_1,top_n_user_2))/15
similarity_SVD_50 <- append(similarity_SVD_50,tt)}similarity_SVD_10_mean = mean(similarity_SVD_10)
similarity_SVD_20_mean = mean(similarity_SVD_20)
similarity_SVD_30_mean = mean(similarity_SVD_30)
similarity_SVD_40_mean = mean(similarity_SVD_40)
similarity_SVD_50_mean = mean(similarity_SVD_50)
means = c(similarity_SVD_10_mean,similarity_SVD_20_mean,similarity_SVD_30_mean,similarity_SVD_40_mean,similarity_SVD_50_mean)
svds = c(10,20,30,40,50)b <- data.frame(svd=svds, mean=means)
plot(b,
main="Übereinstimmender Empfehlungen der Top-15 Liste ",
xlab="Singulärwerte für SVD",
ylab="Durchschnitt der Übereinstimmung",)
Beschreibung:
In dieser Grafik überprüfen wir, wie sich der Anteil übereinstimmender Empfehlungen der Top-15 Liste für IBCF zu verschiedene SVD Modelle verändert, wenn wir die Anzahl der Singulärwerte für SVD verändern. Die Übereinstimmung variiert sehr schwach. Dadurch können wir sagen, dass die Änderung der Singulärwerte von SVD keinen grossen Einfluss auf die Übereinstimmung haben
Aufgabe Seite 12
Bestimme aus 5 unterschiedlichen Modellen das hinsichtlich Top N Empfehlungen beste Modell. Begründe deine Modellwahlen aufgrund der bisher gemachten Erkenntnisse und verwende als 6. Modell einen Top Movie Recommender (Basis: reduzierter Datensatz).
- Verwende für die Evaluierung 10 fache Kreuzvalidierung,
- Begründe deine Wahl der Performance Metrik,
- Analysiere das beste Modell für Top N Recommendations mit N gleich 10, 15, 20, 25 und 30,
- Optimiere dein bestes Modell hinsichtlich Hyperparameter. Hinweis: Verwende für den Top Movie Recommender die Filme mit den höchsten Durchschnittsratings.
Sources
https://michael.hahsler.net/other_courses/ICMA_Recommendation_Tools/code/evaluation.html https://michael.hahsler.net/other_courses/ICMA_Recommendation_Tools/code/ https://cran.r-project.org/web/packages/recommenderlab/vignettes/recommenderlab.pdf
Alle möglichen Recommendermodelle sind mit dieser Funktion sichtbar:
recommenderRegistry$get_entry_names()## [1] "HYBRID_realRatingMatrix" "HYBRID_binaryRatingMatrix"
## [3] "ALS_realRatingMatrix" "ALS_implicit_realRatingMatrix"
## [5] "ALS_implicit_binaryRatingMatrix" "AR_binaryRatingMatrix"
## [7] "IBCF_binaryRatingMatrix" "IBCF_realRatingMatrix"
## [9] "LIBMF_realRatingMatrix" "POPULAR_binaryRatingMatrix"
## [11] "POPULAR_realRatingMatrix" "RANDOM_realRatingMatrix"
## [13] "RANDOM_binaryRatingMatrix" "RERECOMMEND_realRatingMatrix"
## [15] "RERECOMMEND_binaryRatingMatrix" "SVD_realRatingMatrix"
## [17] "SVDF_realRatingMatrix" "UBCF_binaryRatingMatrix"
## [19] "UBCF_realRatingMatrix"recommenderRegistry$get_entry("UBCF", dataType="realRatingMatrix")## Recommender method: UBCF for realRatingMatrix
## Description: Recommender based on user-based collaborative filtering.
## Reference: NA
## Parameters:
## method nn sample weighted normalize min_matching_items min_predictive_items
## 1 "cosine" 25 FALSE TRUE "center" 0 0recommenderRegistry$get_entry("IBCF", dataType="realRatingMatrix")## Recommender method: IBCF for realRatingMatrix
## Description: Recommender based on item-based collaborative filtering.
## Reference: NA
## Parameters:
## k method normalize normalize_sim_matrix alpha na_as_zero
## 1 30 "Cosine" "center" FALSE 0.5 FALSErecommenderRegistry$get_entry("SVD", dataType="realRatingMatrix")## Recommender method: SVD for realRatingMatrix
## Description: Recommender based on SVD approximation with column-mean imputation.
## Reference: NA
## Parameters:
## k maxiter normalize
## 1 10 100 "center"um herauszufinden welcher Ansatz auf unseren Daten der Vielversprechenste ist, wird eine Cross-Validierung mit 10 separaten Splits durchgeführt. Dabei wird jeweils, dass Verhältnis der Training und Testdaten in 80% verwendet. Danach wird auf den Trainingsdaten die Kreuzvalidierung durchgeführt mit jeweils 10 Splits, die so von der Aufgabenstellung vorgegeben wurden. Eine Unterscheidung der Güte der Impliziten und Expliziten Modelle ist schwer anzustellen, da man für die Klassifikationsmetriken einen Schwellwert zur binären Übertragung definieren muss. Gemäss diesem Schwellwert können die Resultate stark variieren. Dies wird mit dem Parameter goodRating festgelegt. Auf diesen Parameter wird im späteren Verlauf der Arbeit noch weiter eingegangen.
# Konvertieren in RealRatingmatrizen
Movies_reduced <- coerce(MovieLense_user_movies_reduced_df, MovieLense)## Warning in coerce(MovieLense_user_movies_reduced_df, MovieLense): direct use of
## coerce() is deprecated: use as(from, class(to)) insteadMovies_random <- coerce(Movies_random_selected_df, MovieLense)## Warning in coerce(Movies_random_selected_df, MovieLense): direct use of coerce()
## is deprecated: use as(from, class(to)) insteadMovies_top_movies <- coerce(MoviesLense_random_user_top_movies_df, MovieLense)## Warning in coerce(MoviesLense_random_user_top_movies_df, MovieLense): direct use
## of coerce() is deprecated: use as(from, class(to)) insteadgiven_ratings_in_cv <- 10
goodRating_threshold <- 3
eval_scheme <- recommenderlab::evaluationScheme(data = Movies_reduced,
method="cross-validation" , train=80,
k=10, given=given_ratings_in_cv,
goodRating=goodRating_threshold)
eval_top_movies <- recommenderlab::evaluationScheme(data = Movies_top_movies,
method="cross-validation" , train=80,
k=10, given=given_ratings_in_cv,
goodRating=goodRating_threshold)
MovieLense_random_user_top_movie_norm <- recommenderlab::normalize(coerce(MoviesLense_random_user_top_movies_df, MovieLense))## Warning in coerce(MoviesLense_random_user_top_movies_df, MovieLense): direct use
## of coerce() is deprecated: use as(from, class(to)) insteadalgorithms <- list(
RANDOM = list(name = "RANDOM", param = NULL),
IBCF_cos = list(name = "IBCF", param = list(k = 30, method = "Cosine")),
IBCF_jacc = list(name = "IBCF", param = list(k =30, method = "Jaccard")),
UBCF_cos = list(name = "UBCF", param = list(nn = 30, method = "Cosine")),
UBCF_jacc = list(name = "UBCF", param = list(nn = 30, method = "Jaccard")),
SVD = list(name = "SVD", param = list(k = 30))
)
n_recommendations <- c(10, 15, 20, 25, 30)
results_explicit <- evaluate(x = eval_scheme,
method = algorithms,
n = n_recommendations)## RANDOM run fold/sample [model time/prediction time]
## 1 [0sec/0.01sec]
## 2 [0sec/0.01sec]
## 3 [0sec/0.01sec]
## 4 [0sec/0.01sec]
## 5 [0sec/0.01sec]
## 6 [0sec/0.02sec]
## 7 [0.02sec/0sec]
## 8 [0sec/0.01sec]
## 9 [0sec/0.02sec]
## 10 [0sec/0.02sec]
## IBCF run fold/sample [model time/prediction time]
## 1 [0.44sec/0.02sec]
## 2 [0.58sec/0sec]
## 3 [0.41sec/0.01sec]
## 4 [0.42sec/0.02sec]
## 5 [0.59sec/0sec]
## 6 [0.43sec/0.02sec]
## 7 [0.44sec/0sec]
## 8 [0.44sec/0sec]
## 9 [0.43sec/0.02sec]
## 10 [0.57sec/0sec]
## IBCF run fold/sample [model time/prediction time]
## 1 [0.41sec/0.02sec]
## 2 [0.41sec/0.01sec]
## 3 [0.41sec/0.01sec]
## 4 [0.42sec/0.01sec]
## 5 [0.42sec/0sec]
## 6 [0.41sec/0sec]
## 7 [0.42sec/0sec]
## 8 [0.42sec/0.01sec]
## 9 [0.42sec/0sec]
## 10 [0.43sec/0sec]
## UBCF run fold/sample [model time/prediction time]
## 1 [0sec/0.06sec]
## 2 [0sec/0.07sec]
## 3 [0sec/0.08sec]
## 4 [0sec/0.06sec]
## 5 [0sec/0.07sec]
## 6 [0sec/0.06sec]
## 7 [0sec/0.06sec]
## 8 [0sec/0.07sec]
## 9 [0sec/0.06sec]
## 10 [0sec/0.06sec]
## UBCF run fold/sample [model time/prediction time]
## 1 [0.02sec/0.05sec]
## 2 [0.02sec/0.06sec]
## 3 [0sec/0.06sec]
## 4 [0sec/0.07sec]
## 5 [0.02sec/0.05sec]
## 6 [0sec/0.06sec]
## 7 [0sec/0.07sec]
## 8 [0.02sec/0.05sec]
## 9 [0sec/0.06sec]
## 10 [0sec/0.07sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.09sec/0sec]
## 2 [0.06sec/0.01sec]
## 3 [0.06sec/0.02sec]
## 4 [0.08sec/0.02sec]
## 5 [0.07sec/0.01sec]
## 6 [0.06sec/0.02sec]
## 7 [0.06sec/0.01sec]
## 8 [0.08sec/0.01sec]
## 9 [0.08sec/0sec]
## 10 [0.06sec/0.02sec]# Plot confusion matrix
plot_confusion_matrix <- function(eval_results){
tmp <- results_explicit$IBCF_cos %>%
getConfusionMatrix() %>%
as.list()
}
extract_binary_metric_vals <- function(eval_results){
#' Extracts Evaluation result and returns binary metrics TP, FP, FN, TN
#'
#' Usage:
#' >> extract_binary_metric_vals(results$IBCF_cos)
tmp <- results_explicit$IBCF_cos %>%
getConfusionMatrix() %>%
as.list()
all_data <- data.frame()
for (i in 1:length(tmp)){
df_tmp <- as.data.frame(tmp[[i]])[, c("n", "TP", "FP", "FN", "TN")]
df_tmp[,"iter"]<- i
all_data <- rbind(all_data, df_tmp)
}
all_data <- all_data %>%
group_by(iter) %>%
summarise(TP=mean(TP), FP=mean(FP),
FN=mean(FN), TN=mean(TN)) %>%
#select(c(TP, FP, FN, TN)) %>%
round()
return(all_data)
}
#results <- extract_binary_metric_vals(results_explicit$RANDOM)
#resultsplot(results_explicit, annotate=TRUE, asp=TRUE, legend="topright")
Beschreibung:
Die Grafik zeigt die Receiver Operating Characteristic (ROC) und setzt dabei die True-Positive Rate ins Verhältnis zur False-Positive Rate.
Für die ROC-Kurve werden folgende Metriken verwendet:
\[TPR=Specifity=Recall=\frac{TP}{TP+FN}, \quad FPR=1-Specitifiy=\frac{FP}{FP+TN}\] Die Grafik interpretiert man sodass, man die Diagonale Linie als zufällige Vorhersage gewertet wertet. Weiter möchte man durch eine möglichst hohe TPR, sprich Verhältnis der richtig positiven VOrhersagen erreichen und dementsprechend ein kleines Verhältnis der FP Anteile der Vorhersagen haben. (Narkede, 2018)
Im Sinne der Expliziten Ratings wird auch mit SVD, sprich Singulärwertzerlegung das beste Resultat erzielt. Dies ist anhand der Grafik eindeutig klar, da der Verlauf der Kurve sich am stärksten von den anderne absetzt. Diese Grafik ist jedoch mit Vorsicht zu geniessen, denn die Modelle verfügen über Hyperparameter, die in diesem Beispiel nicht optimiert wurden. Das SVD Modell erzielt im Sinne bei der Scores die besten Resultate für die TPR, da sie bei allen N-Recommendations die besten Werte erzielt. In der Grafik sind auch Modelle zu sehen, wie die UBCF, die bei gewissen N-Recommendations schlechter abschneiden, als zufällige Recommendationen. Im weiteren Verlauf werden wir uns bei expliziten Ratings auf SVD fokussieren, aufgrund der eindeutigen Resultate.
plot(results_explicit, "prec/rec", annotate=TRUE)
Beschreibung:
Der Plot zeigt eine Gegenüberstellung der Precision und des Recalls über N-Recommendationen hinweg. Auch hier zeichnet sich ähnliches ab. Das SVD-Modell erreicht die besten Werte für Precision und auch Recall für alle N-Recommendations. Man kann hier auch einen Reim aus der absteigenden Kurve des Precision und der zunehmenden des Recalls machen, da die Wahrscheinlichkeit für wenig N-Recommendationen eher hoch ist ein Item zu treffen, dass im Testset vorhanden ist. Umso mehr Items empfohlen werden, desto kleiner werden die Anteile von TP und es steigen die als FP und FN vorhergesagten.
Die beiden geplotteten Metriken sind so definiert:
\[Precision=\frac{TP}{TP+FP}, \quad Recall=\frac{TP}{FN + TP}\]
Parameteroptimierung
Bei den Untersuchungen war SVD das stärkste Modell mit den Standardparametern. Bei diesem Modell existieren noch zwei Hyperparameter mit denen man noch ein besseres Modell erzielt werden kann. Diese sind die Anzahl der Nachbaren, die Anzahl der Iterationen, die verwendet werden um die Singulärwerte zu finden. Anzahl der Singulärwerte, die zur Rekonstruktion der Ratingmatrix benötigt werden.
Grundlegend wird SVD als Matrizenzerlegung der Ratingmatrix \(A\) angesehen als: \(A \approx U\Sigma T^T\) wobei \(U=\sigma(AA^T)\) der gefundenen normierten Eigenvektoren aus der Symmetrischen Matrix \(AA^T\) darstellen. Für \(\Sigma=\sqrt{\sigma}\) ergibt sich eine Diagonalmatrix aus Singulärwerten. Die Matrix \(T\) entpricht den gefundenen Eigenvektoren aus der symmetrischen MAtrix \(T = \sigma(A^TA)\). Durch das Beschneiden der Matrizenzerlegung kann dadurch eine Annäherung an die Matrix \(A\) erzielt werden, mit welcher unteranderem auch zuvor nicht vorhandene Werte gefüllt werden, bzw. vorhergesagt werden.
Vorerst blicken wir auf die Parameter des SVD-Recommenders aus Recommenderlab.
recommenderRegistry$get_entry("SVD", dataType="realRatingMatrix")## Recommender method: SVD for realRatingMatrix
## Description: Recommender based on SVD approximation with column-mean imputation.
## Reference: NA
## Parameters:
## k maxiter normalize
## 1 10 100 "center"Der Hyperparameter k dient zur Beschneidung der Matrizenzerlegung die dann zur Annäherung der Ratingmatrix genutzt wird. Desto grösser gewählt, desto besser der Fit auf den Trainingsdaten. Desto besser die Rekonstruktion der Input-Matrix.
# Evaluation
algorithms_svd <- list(
SVD_2 = list(name = "SVD", param = list(k = 2)),
SVD_5 = list(name = "SVD", param = list(k = 5)),
SVD_10 = list(name = "SVD", param = list(k = 10)),
SVD_20 = list(name = "SVD", param = list(k = 20)),
SVD_30 = list(name = "SVD", param = list(k = 30)),
SVD_40 = list(name = "SVD", param = list(k = 40)),
SVD_50 = list(name = "SVD", param = list(k = 50))
)
given_ratings_in_cv <- 10
goodRating_threshold <- 3
eval_scheme <- recommenderlab::evaluationScheme(data = Movies_reduced,
method="cross-validation" , train=80,
k=10, given=given_ratings_in_cv,
goodRating_threshold)
ev <- evaluate(eval_scheme, algorithms_svd, type="topNList", n=c(10, 15, 20, 25, 30))## SVD run fold/sample [model time/prediction time]
## 1 [0.01sec/0.02sec]
## 2 [0.02sec/0.01sec]
## 3 [0.02sec/0.01sec]
## 4 [0.01sec/0sec]
## 5 [0.02sec/0.01sec]
## 6 [0.02sec/0sec]
## 7 [0.01sec/0sec]
## 8 [0.03sec/0sec]
## 9 [0.01sec/0.02sec]
## 10 [0.02sec/0.01sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.01sec/0.02sec]
## 2 [0.01sec/0.02sec]
## 3 [0.02sec/0.01sec]
## 4 [0.02sec/0.01sec]
## 5 [0.01sec/0.02sec]
## 6 [0.02sec/0.01sec]
## 7 [0.02sec/0.01sec]
## 8 [0.02sec/0.01sec]
## 9 [0.01sec/0.02sec]
## 10 [0.01sec/0.02sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.03sec/0sec]
## 2 [0.04sec/0sec]
## 3 [0.03sec/0.02sec]
## 4 [0.04sec/0sec]
## 5 [0.03sec/0.02sec]
## 6 [0.03sec/0.02sec]
## 7 [0.15sec/0sec]
## 8 [0.02sec/0.01sec]
## 9 [0.03sec/0sec]
## 10 [0.03sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.05sec/0.01sec]
## 2 [0.04sec/0sec]
## 3 [0.05sec/0.01sec]
## 4 [0.05sec/0.01sec]
## 5 [0.04sec/0sec]
## 6 [0.06sec/0sec]
## 7 [0.03sec/0.02sec]
## 8 [0.04sec/0sec]
## 9 [0.05sec/0sec]
## 10 [0.03sec/0.02sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.07sec/0.01sec]
## 2 [0.08sec/0sec]
## 3 [0.08sec/0.02sec]
## 4 [0.06sec/0.02sec]
## 5 [0.08sec/0.02sec]
## 6 [0.08sec/0sec]
## 7 [0.08sec/0.01sec]
## 8 [0.06sec/0.02sec]
## 9 [0.06sec/0.02sec]
## 10 [0.07sec/0.01sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.11sec/0.01sec]
## 2 [0.09sec/0.02sec]
## 3 [0.1sec/0.01sec]
## 4 [0.11sec/0.01sec]
## 5 [0.09sec/0.02sec]
## 6 [0.1sec/0.01sec]
## 7 [0.09sec/0.02sec]
## 8 [0.1sec/0sec]
## 9 [0.08sec/0.01sec]
## 10 [0.1sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.13sec/0sec]
## 2 [0.13sec/0.01sec]
## 3 [0.11sec/0.02sec]
## 4 [0.14sec/0.02sec]
## 5 [0.15sec/0.02sec]
## 6 [0.13sec/0.01sec]
## 7 [0.14sec/0sec]
## 8 [0.14sec/0sec]
## 9 [0.14sec/0.02sec]
## 10 [0.13sec/0.01sec]eval_ratings <- evaluate(eval_scheme, algorithms_svd, type="ratings")## SVD run fold/sample [model time/prediction time]
## 1 [0.02sec/0sec]
## 2 [0.01sec/0sec]
## 3 [0.01sec/0sec]
## 4 [0.02sec/0.01sec]
## 5 [0.02sec/0sec]
## 6 [0.01sec/0.02sec]
## 7 [0.02sec/0sec]
## 8 [0.02sec/0sec]
## 9 [0.01sec/0sec]
## 10 [0.01sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.02sec/0.01sec]
## 2 [0.02sec/0sec]
## 3 [0.01sec/0sec]
## 4 [0.03sec/0sec]
## 5 [0.03sec/0sec]
## 6 [0.02sec/0.02sec]
## 7 [0.01sec/0sec]
## 8 [0.01sec/0sec]
## 9 [0.03sec/0sec]
## 10 [0.02sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.04sec/0sec]
## 2 [0.03sec/0sec]
## 3 [0.03sec/0sec]
## 4 [0.02sec/0.02sec]
## 5 [0.03sec/0sec]
## 6 [0.03sec/0sec]
## 7 [0.02sec/0.01sec]
## 8 [0.04sec/0sec]
## 9 [0.02sec/0.01sec]
## 10 [0.03sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.05sec/0.02sec]
## 2 [0.04sec/0sec]
## 3 [0.05sec/0sec]
## 4 [0.04sec/0sec]
## 5 [0.05sec/0sec]
## 6 [0.05sec/0.01sec]
## 7 [0.05sec/0sec]
## 8 [0.05sec/0sec]
## 9 [0.05sec/0sec]
## 10 [0.05sec/0.01sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.06sec/0.02sec]
## 2 [0.08sec/0sec]
## 3 [0.08sec/0sec]
## 4 [0.06sec/0sec]
## 5 [0.08sec/0sec]
## 6 [0.08sec/0sec]
## 7 [0.07sec/0sec]
## 8 [0.08sec/0sec]
## 9 [0.08sec/0sec]
## 10 [0.06sec/0.02sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.11sec/0sec]
## 2 [0.09sec/0.02sec]
## 3 [0.09sec/0sec]
## 4 [0.09sec/0.02sec]
## 5 [0.09sec/0.01sec]
## 6 [0.1sec/0sec]
## 7 [0.1sec/0.01sec]
## 8 [0.1sec/0sec]
## 9 [0.08sec/0.02sec]
## 10 [0.11sec/0sec]
## SVD run fold/sample [model time/prediction time]
## 1 [0.14sec/0.01sec]
## 2 [0.13sec/0.01sec]
## 3 [0.14sec/0sec]
## 4 [0.14sec/0sec]
## 5 [0.12sec/0.02sec]
## 6 [0.13sec/0.01sec]
## 7 [0.13sec/0.01sec]
## 8 [0.14sec/0sec]
## 9 [0.12sec/0.02sec]
## 10 [0.14sec/0sec]plot(ev, "prec/rec", annotate=TRUE, average=TRUE)## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
plot(ev, annotate=TRUE, average=TRUE)## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
## Warning in plot.xy(xy.coords(x, y), type = type, ...): "average" is not a
## graphical parameter
Beschreibung:
Selbe Interpretation der Resultate kann auch beim Precision/Recall Plot entnommen werden.
Die beiden Plots zeigen ein ähnliches Resultat. Für das beste K hinsichtlich beider Metriken ist \(k=5\), welches die zu behaltende Anzahl der Singulärwerte darstellt. Dieser Wert wird als optimal gewählt, da die besten Resultate hinsichtlich der TPR und FPR erreicht werden.
# Aufgabe Seite 12 (DIY)
Implementiere eine Funktion zur effizienten Berechnungn sparsen Ähnlichkeitsmatrizen für IBCF RS und analysiere die Resultate für 100 zufällig gewählte Filme.
Implementiere eine Funktion, um für ordinale Ratings effizient die Cosine Similarity zu berechnen,
Implementiere eine Funktion, um für binäre Ratings effizient die Jaccard Similarity zu berechnen,
Vergleiche deine Implementierung der Cosine basierten Ähnlichkeitsmatrix für ordinale Kundenratings mit der korrespondierenden via Open Source Paketen erzeugten Ähnlichkeitsmatrix,
Vergleiche und diskutiere die Unterschiede deiner mittels Cosine Similarity erzeugten Ähnlichkeitsmatrizen für ordinale und normierte Kundenratings mit der Jaccard basierten Ähnlichkeitsmatrix.
Cosine Similarity
Effiziente Berechnung der Cosine-Similarity zwischen den einzelnen Items.
\[sim(U, U)=\frac{U^TU}{||U||_2*||U||^T_2}\] Der Nenner repräsentiert das Skalarprodukt eines jeden Vektors mit sich selbst und kann als MAtrizenprodukt geschrieben werden. Der untere Teil repräsentiert die L2-Norm von jedem Vektor, was die Wurzel aus dem Produkt mit sich selbst geschrieben werden kann.
# Cosine Similarity %*%
item_item_cosine <- function(M, make_sparse=FALSE){
#M <- coerce(M, matrix())
if (make_sparse){
M <- Matrix(M, sparse = TRUE)
}
M <- t(M) %*% M / sqrt(colSums(M**2)) %*% t(sqrt(colSums(M**2)))
return(M)
}
sample_mat <- Movies_reduced
sample_mat <- as(sample_mat, "matrix")
sample_mat <- replace_na(sample_mat, 0)
cosine_custom <- item_item_cosine(M = sample_mat)
cosine_package <- coop::cosine(x = sample_mat)
err <- abs(cosine_custom - cosine_package)
# err <- coerce(err, matrix())
err <- mean(err)
print(paste("Mean Absolute Error: ", err))## [1] "Mean Absolute Error: 1.28242088150579e-19"measure_custom <- bench::mark(item_item_cosine(M = sample_mat))
measure_package <- bench::mark(coop::cosine(x = sample_mat))
measure_benchmark <- rbind(measure_custom, measure_package)
measure_benchmark$expression <- c("custom", "package")
measure_benchmark## # A tibble: 2 x 6
## expression min median `itr/sec` mem_alloc `gc/sec`
## <chr> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl>
## 1 custom 96.8ms 97.3ms 10.3 14.02MB 5.13
## 2 package 65.4ms 65.6ms 15.2 3.74MB 0Man kann sehen, dass unsere Funktion schnellere Zeiten vorweist, als die von dem Package. Es könnte durchaus sein, dass während der Durchführung des Packages die Matrizen in ein Sparse-Format konvertiert werden bevor die Similarity gerechnet wird. Die Speicherkonsumption des Package ist jedoch besser als unsere. Für unsere Funktion haben wir noch einen zusätzlichen Paramaeter integriert mit dem man wählen kann ob die MAtrix auch in eine Sparse-Format konvertiert werden sollte. Bei grösseren Matrizen wird das Package schneller, doch dies haben wir hier nicht dargestellt und nur basierend auf unseren Ratingmatrizen gearbeitet. Man kann also daraus schliessen, dass unsere eigne Funktion hinsichtlich der Geschwindigkeit besser geieignet ist, als das Package coop.
Jaccard Similarity
\[Jaccard Similarity = \frac{A \cap B}{A \cup B}\] Diese Metrik wird auch IoU genannt - Intersection over Union. Dabei wird geschaut wieviele gleiche hat es von der Kenngrösse, dividiert durch die Gesamtanzahl der Elemente in \(A\) und \(B\).
Unsere Implementation mit Matrizenoperationen sieht so aus:
\[Jaccard Similarity(X^{MxN}) = \frac{X^TX}{M-(1-X)^T(1-X)}\]
Dabei wird aus der ordinalen Ratingmatrix eine binäre Ratingmatrix gemacht mit einem Boolean Filter in dem alle Werte grösser als 0 zu 1 werden und der Rest 0. Mit dem Matrizenprodukt \(X^TX\) können nun die Sklarprodukte zwischen allen Spaltenvektoren berechnet werden. Dies wiederspricht der Intersektion oder auch der Interaktion zweier Produkte. Mit dem Divident wird im eigentlichen Sinne durch \((1-X)^T(1-X)\) die Komplementärmenge in einem Venn-Diagramm dargestellt. Wenn man nun die Gesamtmenge \(M\) der Komplementärmenge abzieht, resultiert dabei die Vereingungsmenge(Union).
sample_mat <- Movies_reduced
sample_mat <- as(sample_mat, "matrix")
sample_mat <- replace_na(sample_mat, 0)
item_item_jaccard <- function(X){
# Binarize
X <- ifelse(test = X>0, yes = 1, no = 0)
# Calculation of Union as Matrixprod
intersectX <- t(X) %*% X
# Invert X
X <- 1 - X
# Calculate Complement
unionX <- t(X) %*% X
# Get union by subtracting All - Complement
unionX <- dim(X)[1] - unionX
# Calc Similarity
jaccard_sim <- intersectX / unionX
return(jaccard_sim)
}
#helper function
onezero <- function(nrow,ncol){
return(matrix(sample(c(0,1), replace=T, size=nrow*ncol), nrow=nrow))
}
S <- onezero(10, 30)
res_package <- vegan::vegdist(t(S), method = "jaccard" ,diag = TRUE, upper = TRUE)
res_package <- as.matrix(res_package)
res_custom <- item_item_jaccard(S)
err <- abs(res_package - (1-res_custom))
# err <- coerce(err, matrix())
err <- mean(err)
print(paste("Mean Absolute Error: ", err))## [1] "Mean Absolute Error: 4.35454141880756e-17"Beschreibung:
Die beiden Funktionen ergeben fast das gleiche. Unsere Implementierung müsste noch mit der Funktion \(Sim_{vegan}=1-Sim_{Custom}\) ergänzt werden. Wir nehmen an, dass dieses Package die Jaccard-Distanz abbildet. Die Gleichheit der Resultate stimmt überein, da der Durschnittliche Absolute Fehler beider Arrays sehr klein ist und wahrscheinlich auf die Dezimal-Darstellung der Werte zurückzuführen ist.
measure_custom <- bench::mark(item_item_jaccard(X = sample_mat))
measure_package <- bench::mark(vegan::vegdist(t(sample_mat), method = "jaccard" ,
diag = TRUE, upper = TRUE))
measure_benchmark <- rbind(measure_custom, measure_package)
measure_benchmark$expression <- c("Custom", "Package")
measure_benchmark## # A tibble: 2 x 6
## expression min median `itr/sec` mem_alloc `gc/sec`
## <chr> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl>
## 1 Custom 197ms 202ms 4.96 36.4MB 2.48
## 2 Package 203ms 203ms 4.93 11.6MB 2.46Beschreibung:
Beim Vergleich beider Modelle kann man sehen, dass auf unserer Matrix unsere eigne Funktion besser performt. Jedoch ist auch erkennbar, dass die Speicherauslastung unserer Funktion um einiges höher liegt, als die vom Package. Dies könnte daran liegen, dass kleinere Datentypen verwendet werden oder mit Sparse-Matrizen gearbeitet wird.
Vergleich Cosine-Jaccard
- Vergleiche und diskutiere die Unterschiede deiner mittels Cosine Similarity erzeugten Ähnlichkeitsmatrizen für ordinale und normierte Kundenratings mit der Jaccard basierten Ähnlichkeitsmatrix.
M <- as(Movies_reduced, "matrix")
M <- replace_na(M, 0)
similarity_matrix_cosine <- item_item_cosine(M=M)
similarity_matrix_cosine <- colMeans(similarity_matrix_cosine)
similarity_matrix_jaccard <- item_item_jaccard(X = M)
similarity_matrix_jaccard <- colMeans(similarity_matrix_jaccard)
col_means_normal <- as.data.frame(similarity_matrix_cosine)
col_means_normal$jaccard <- as.data.frame(similarity_matrix_jaccard)$similarity_matrix_jaccard
p1 <- hist(col_means_normal$similarity_matrix_cosine, xlab="Mean Ratings all Items", main = "Col Means: Cosine Similarity on ordinal Ratings", col = "grey")
p2 <- hist(col_means_normal$jaccard, xlab="Mean Ratings all Items", main = "Col Means: Jaccard Similarity on ordinal Ratings", col = "grey")
Beschreibung:
Der linke Plot zeigt das Historgram für die Mean Ratings pro Item, die mit anhand der Cosine Similarity berechnet wurde und der zweite Plot die kalkulierten Mean Ratings pro Produkt mit der Jaccard Similarity.
Die Unterscheidung fällt bereits anhand der Skala auf, die Durchschnittlichen Kosinus-Similaritäten sind um einiges grösser, als die Durchschnittlichen Ratings der Jaccard-Similairtäten. Eine plausible Erklärung bietet die Sparsity, welche grundsätzlich hoch ist, da viele Filme auch im reduzierten Datensatz von wenigen Usern geschaut wurden. Deshalb die Überschneidungen (Intersection) da eher klein sind zwischen einzelnen Usern. Jaccard rechnet nur mit den konsumierten Filmen, wohingegeben Cosine auch Ähnlichkeiten zwischen Nicht geschauten Filmen miteinkalkuliert. Die beiden Funktionen unterscheiden sich grundlegend voneinander, sowie auch deren Verwendung. Beim Jaccard werden die Werte anfangs binärisiert, was sich grundlegend auf die SImilarities auswirkt. Würden sie nicht Binärisiert werden und nur ein Exaktes Match funktionieren, dann hätte man noch viel niedrige Resultate.
normalized_ratings <- recommenderlab::normalize(Movies_reduced)
N <- as(normalized_ratings, "matrix")
N <- replace_na(N, 0)
similarity_matrix_cosine <- item_item_cosine(M=N)
similarity_matrix_cosine <- colMeans(similarity_matrix_cosine)
similarity_matrix_jaccard <- item_item_jaccard(X = N)
similarity_matrix_jaccard <- colMeans(similarity_matrix_jaccard)
col_means_normal <- as.data.frame(similarity_matrix_cosine)
col_means_normal$jaccard <- as.data.frame(similarity_matrix_jaccard)$similarity_matrix_jaccard
p1 <- hist(col_means_normal$similarity_matrix_cosine, xlab="Mean Ratings all Items", main = "Col Means: Cosine Similarity on Normalized Ratings", col = "grey")
p2 <- hist(col_means_normal$jaccard, xlab="Mean Ratings all Items", main = "Col Means: Jaccard Similarity on Normalized Ratings", col = "grey")
Beschreibung:
Auch hier sieht man einen klaren Unterschied beider Resultate. Die Durchschnittliche Similarity für Cosine streut um den Wert 0, welcher durch das Mean-Centering erreicht der Noramlisierung erreicht wird. Bei Jaccard sind die Resultate nur positiv, dies aufgrund der Binärisierung von den Werten grösser 0. Somit werden die normalisierten Ratings, die negativ durch die Normalisierung wurden zu 0 und dementsprechend werden sie nicht mehr als Interaktion mitgezählt.
Coverage@N und Novelty@N
1.Implementiere eine Funktion, um aus Top-N Listen für alle Kunden die Item- space Coverage@N und Novelty@N eines Recommenders zu beurteilen und teste diese.
Beschreibung Für diese Aufgabe vergleichen wir ein gutes IBCF-Modell und das gefundene SVD5 Modell.
SEED <- 42
set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)## Warning in coerce(MovieLense_user_movies_reduced_df, MovieLense): direct use of
## coerce() is deprecated: use as(from, class(to)) insteadIBCF_reduced <- Recommender(data = getData(eval_reduced, "train"), method = "IBCF",
parameter = list(k = 3, method = "Cosine", na_as_zero=TRUE))
SVD_reduced <- Recommender(data = getData(eval_reduced, "train"), method = "SVD",
parameter = list(k = 5))top_n_to_df <- function(top_n){
#' @description Function to transform a TopNList object to a data.frame object.
#' @param topn Topn List
topn_df <- data.frame(user = names(as(top_n, 'list')),
rating = unlist(top_n@ratings), index = unlist(top_n@items))
topn_df$item <- top_n@itemLabels[topn_df$index]
topn_df$year <- MovieLenseMeta$year[topn_df$index]
topn_df <- topn_df[order(topn_df$user),]
topn_df
}
calc_coverage <- function(top_n, n_movies=1664){
#' @description Function, which returns coverage
#' @param top_n Top_n list generated by `recommenderlab::predict`
#' @param n_movies How many total movies there are. In the MovielenseDB, there are 1664 Movies.
top_n = as(top_n, 'list')
unique_pred_movies = unique(unlist(top_n, recursive = FALSE))
n_unique_pred_movies = length(unique_pred_movies)
return (n_unique_pred_movies / n_movies)
}
calc_popularity <- function(MovieLenseData, n_users=943){
#' @description Function, which returns coverage as described here: https://ds-spaces.technik.fhnw.ch/6rsy/2021/05/02/recommender-system-evaluierung-coverage-und-novelty/
#' @param MovieLenseData Movielense data.frame, containing how a user has rated a movie.
#' @param n_movies How many total movies there are. In the MovielenseDB, there are 1664 Movies.
popularity_movie <- MovieLenseData %>%
count(item) %>%
mutate(popularity = n / n_users) %>%
select(item, popularity)
return (popularity_movie)
}
calc_novelty <- function(top_n, MovieLenseData, n_movies=1664){
#' @description Function, which returns novelty as described here: https://ds-spaces.technik.fhnw.ch/6rsy/2021/05/02/recommender-system-evaluierung-coverage-und-novelty/
#' @param top_n Top_n list generated by `recommenderlab::predict`
#' @param MovieLenseData MovieLense Dataset as data.frame
#' @param n_movies How many total movies there are. In the MovielenseDB, there are 1664 Movies.
popularity = calc_popularity(MovieLenseData, n_movies)
top_n_df <- top_n_to_df(top_n)
group_size_user = top_n_df %>%
group_by(user) %>%
summarise(n = n()) %>%
select(user, n)
top_n_df <- top_n_df %>%
left_join(group_size_user, by = 'user')
top_n_popularity_df <- top_n_df %>%
inner_join(popularity, by = 'item') %>%
mutate(popularity = log2(popularity / n))
novelty = sum(top_n_popularity_df$popularity)
S = length(unique(MovieLenseData$user))
novelty = - novelty / S
return (novelty)
}n_list = c(3:15)
given_list = c(3:7)# Test coverage and novelty on 5, 10, 15, 20, 25 and 30 top_n predictions.
options(warn = - 1)
coverage_svd <- matrix(nrow = length(n_list), ncol = length(given_list), dimnames=list(n_list,given_list))
novelty_svd <- matrix(nrow = length(n_list), ncol = length(given_list), dimnames=list(n_list,given_list))
coverage_ibcf <- matrix(nrow = length(n_list), ncol = length(given_list), dimnames=list(n_list,given_list))
novelty_ibcf <- matrix(nrow = length(n_list), ncol = length(given_list), dimnames=list(n_list,given_list))
for(n in 1:length(n_list)){
for (g in 1:length(given_list)){
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, k = 3, given=g)
top_n = predict(object = IBCF_reduced, newdata = getData(eval_reduced, "unknown"), n = n)
coverage_ibcf[n, g] = calc_coverage(top_n)
novelty_ibcf[n, g] = calc_novelty(top_n, MovieLense_df)
top_n = predict(object = SVD_reduced, newdata = getData(eval_reduced, "unknown"), n = n)
coverage_svd[n, g] = calc_coverage(top_n)
novelty_svd[n, g] = calc_novelty(top_n, MovieLense_df)
}
}melted_coverage_ibcf <- melt(coverage_ibcf, value.name = "Coverage", varnames=c('N', 'given'))
melted_novelty_ibcf <- melt(novelty_ibcf, value.name = "Novelty", varnames=c('N', 'given'))
melted_coverage_svd <- melt(coverage_svd, value.name = "Coverage", varnames=c('N', 'given'))
melted_novelty_svd <- melt(novelty_svd, value.name = "Novelty", varnames=c('N', 'given'))ggplot(data = melted_coverage_svd, aes(x=N, y=given, fill=Coverage)) +
geom_raster() +
ggtitle('SVD5: Coverage given vs. N')
ggplot(data = melted_novelty_svd, aes(x=N, y=given, fill=Novelty)) +
geom_raster() +
ggtitle('SVD5: Novelty given vs. N')
ggplot(data = melted_coverage_ibcf, aes(x=N, y=given, fill=Coverage)) +
geom_raster() +
ggtitle('IBCF: Coverage given vs. N')
ggplot(data = melted_novelty_ibcf, aes(x=N, y=given, fill=Novelty)) +
geom_raster() +
ggtitle('IBCF: Novelty given vs. N')
Beschreibung
Lesebeispiel: Es ist eine Heatmap. Wenn man z.B. bei given = 4 und N = 8 auf das Feld schaut, wo sie sich keuzen, können wir anhand der Farben den Wert der Novelty und Coverage abgelesen.
Sowohl bei der Coverage, als auch bei der Novelty hat der Parameter N einen grossen einfluss. Falls man diese beiden maximieren möchte, sollte man ein mögichst hohes N wählen. Given beeinflusst die beiden Metriken fast gar nicht und das ist identisch bei beiden Modellen. Interessanterweise erreicht das SVD5 Modell aber einen höheren Wert und dies überprüfen wir im nächsten Plot.
df <- data.frame(Value=c(sum(melted_novelty_ibcf$Novelty), sum(melted_novelty_svd$Novelty), sum(melted_coverage_ibcf$Coverage), sum(melted_coverage_svd$Coverage)),
Metric=c('IBCF: Novelty', 'SVD5: Novelty', 'IBCF: Coverage', 'SVD: Coverage')
)
p<-ggplot(data=df, aes(x=Metric, y=Value)) +
geom_bar(stat="identity") +
ggtitle('Novelty and Coverage of Models SVD5 and IBCF')
p
Beschreibung
Hier sehen wir die Summe der Werte über die ganze Heatmap und tatsächlich erreicht hier das Modell SVD bei der Coverage und der Novelty einen höheren Wert.
avg_to_df <- function(evlist){
#' @description gets the confusion matices from `evlist` and transforms it to a single data.frame
#' @param evlist evaluationResultList
#' @return data.frame confusion matrix with all recommenders as rec and number of recommendations as n
evaluation_avg <- data.frame()
for (i in 1:length(evlist)){
current_avg <- as.data.frame(avg(evlist[i]))
colnames(current_avg) <- c('TP','FP','FN','TN','N', 'precision','recall','TPR','FPR', 'n')
current_avg$specificity <- current_avg$TN * (current_avg$TN + current_avg$FP)**-1
rownames(current_avg) <- NULL
current_avg$model <- names(evlist)[i]
evaluation_avg <- rbind(evaluation_avg, current_avg)
}
return(evaluation_avg)
}
plot_percision_recall <- function(evaluation_avg){
#' @description plots the percision recall curve with the according number of predictions
#' @param evaluation_avg data.frame from avg_to_df
ggplot(evaluation_avg, aes(x=precision, y=recall, label=n)) +
geom_line(aes(color=model)) +
geom_text() +
scale_color_manual(values=1:length(evaluation_avg)) +
ggtitle('Precision Recall Curve') +
xlab('precision') +
ylab('recall')
}Implementierung Top-N Monitor
Aufgabe DIY: Untersuche die relative Übereinstimmung zwischen Top- N Empfehlungen und präferierten Filmen für 4 unterschiedliche Modelle (z.B. IBCF und UBCF mit unterschiedlichen Ähnlichkeits- metriken / Nachbarschaften sowie SVD mit unterschiedlicher Dimensionalitätsreduktion).
1.Fixiere 20 zufällig gewählte Testkunden für alle Modellvergleiche
set.seed(SEED)
random_user_idx = floor(runif(20, min=0, max=nrow(getData(eval_reduced, "unknown"))+1))
test_user_selected = getData(eval_reduced, "unknown")[random_user_idx]
test_user_selected## 20 x 700 rating matrix of class 'realRatingMatrix' with 3638 ratings.2.Bestimme den Anteil der Top-N Empfehlung nach Genres pro Kunde
Beschreibung
Gute Modelle kennen wir schon von der füheren Aufgabe (SVD5). Wir werden diese aber noch auf “given” und “goodRating” analysieren. Wir
algorithms <- list(
IBCF_cos = list(name = "IBCF", param = list(k = 3, method = "Cosine")),
SVD = list(name = "SVD", param = list(k = 5))
)# GOOD_RATING_VALUE
good_rating = 3
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 3"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = 3, goodRating = good_rating)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_3 = avg_to_df(results)# GOOD_RATING_VALUE
good_rating = 4
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = 3, goodRating = good_rating)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_4 = avg_to_df(results)results_4_mean <- results_4 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_3_mean <- results_3 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_3_meanresults_4_meanBeschreibung
Der Paramter goodRating verändert den Recall und die Precision beim Modell SVD5 wie erwartet: Mit einem höheren Wer steigt der Recall und die Precision sinkt. Das ergibt Sinn, da die Wahrscheinlichkeit einen false positive zu haben, steigt.
Given
# GIVEN VALUE
given = 2
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = given, goodRating = 4)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_2 = avg_to_df(results)# GIVEN VALUE
given = 5
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = given, goodRating = 4)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_5 = avg_to_df(results)# GIVEN VALUE
given = 7
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = given, goodRating = 4)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_7 = avg_to_df(results)# GIVEN VALUE
given = 10
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = given, goodRating = 4)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_10 = avg_to_df(results)# GIVEN VALUE
given = -1
print(paste("Good Rating Value: ", good_rating))## [1] "Good Rating Value: 4"# Let's check some algorithms against each other
scheme <- recommenderlab::evaluationScheme(coerce(MovieLense_user_movies_reduced_df,MovieLense) , method = "split", train = 0.8, k=3,
given = given, goodRating = 4)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
# run algorithms, predict next n movies
n = c(1, 3, 5, 10, 15, 20)
results <- evaluate(scheme, algorithms, n=n, progress = FALSE)
results_1 = avg_to_df(results)results_2_mean <- results_2 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_5_mean <- results_5 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_10_mean <- results_10 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_1_mean <- results_1 %>%
group_by(model) %>%
summarize(Recall=mean(recall), Precision=mean(precision))
results_2_meanresults_5_meanresults_10_meanresults_1_meanBeschreibung
Wir können sehen, dass bei beiden der Recall zunimmt. Die Precision korreliert aber weder positiv, noch negativ mit dem Wert für “given”. Es scheint, dass die Precision einen maximalen Wert zwischen 5 und 10 erreicht. Das setting “all-but-1” führt zu einem viel schlechteren Resultat, was intuitiv Sinn ergibt, da ja nur ein Film pro User für die Überprüfung übrig bleibt.
Analyse Genreverteilung
Beschreibung
Für die Genreverteilung schauen wir uns mehr Modelle an, da hier vielleicht das SVD geschlagen wird. Ein Modell zählt als geschlagen, wenn es z.B. überdurchschnittlich oft Dramen empfiehlt, obwohl ein User fast nur Sci-Fi schaut.
top_n_genres <- function(top_n, Movie_Genre, col_name){
#' @algorithms top_n generated by recommenderlab::predict
#' @Movie_Genre Movie_Genre melted MovieLenseData, containing at least the genre and the title of a movie
#' @col_name name for copy of percentages of genres (for easier comparison between different models).
#' @returns genres of users in the top_n list
top_n = top_n_to_df(top_n)
Movie_Genre$item = Movie_Genre$title
genres_top_n <- top_n %>%
left_join(Movie_Genre, by='item') %>%
group_by(user, genre) %>%
summarise(n = n()) %>%
mutate(percent = 100 * n/sum(n))
genres_top_n[,col_name] = genres_top_n$percent
return (genres_top_n)
}set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)
recommender <- Recommender(data = getData(eval_reduced, "train"), method = "IBCF",
parameter = list( method = "Cosine", na_as_zero=TRUE))
top_n = predict(recommender, test_user_selected, n=15)IBCF_top_genre = top_n_genres(top_n, Movie_Genre, 'IBCFCos')## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(IBCF_top_genre, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "IBCF Cosine: Genre of highly rated Movies per User in the Top N list")
set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)
recommender <- Recommender(data = getData(eval_reduced, "train"), method = "UBCF",
parameter = list(nn = 25, method = "Cosine"))
top_n = predict(recommender, test_user_selected, n=15)
UBCF_cos_top_genre = top_n_genres(top_n, Movie_Genre, 'UBCFCos')## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(UBCF_cos_top_genre, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "UBCF Cosine: Genre of highly rated Movies per User in the Top N list")
set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)
recommender <- Recommender(data = getData(eval_reduced, "train"), method = "UBCF",
parameter = list(nn = 25, method = "Jaccard"))
top_n = predict(recommender, test_user_selected, n=15)
UBCF_jacc_top_n_genre = top_n_genres(top_n, Movie_Genre, 'UBCFJacc')## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(UBCF_jacc_top_n_genre, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "UBCF Jaccard: Genre of highly rated Movies per User in the Top N list")
set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)
recommender <- Recommender(data = getData(eval_reduced, "train"), method = "SVD",
parameter = list(k = 5))
top_n = predict(recommender, test_user_selected, n=15)
SVD_5_top_n_genre = top_n_genres(top_n, Movie_Genre, 'SVD5')## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(SVD_5_top_n_genre, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "SVD 5: Genre of highly rated Movies per User in the Top N list")
set.seed(SEED)
eval_reduced <- recommenderlab::evaluationScheme(data = coerce(MovieLense_user_movies_reduced_df, MovieLense),
method="split", train=0.8, given=3)
recommender <- Recommender(data = getData(eval_reduced, "train"), method = "SVD",
parameter = list(k = 10))
top_n = predict(recommender, test_user_selected, n=15)
SVD_10_top_n_genre = top_n_genres(top_n, Movie_Genre, 'SVD10')## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(SVD_10_top_n_genre, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "SVD 10: Genre of highly rated Movies per User in the Top N list")
- Bestimme pro Kunde den Anteil nach Genres seiner Top-Filme (=Filme, welche vom Kunden die besten Bewertungen erhalten haben),
fav_genre_of_users <- function(random_user_idx, MovieLenseData, Movie_Genre, top_rating=4){
#' @random_user_idx vector with random ints
#' @param MovieLenseData Movielense data.frame, containing how a user has rated a movie.
#' @param Movie_Genre melted MovieLenseData, containing at least the genre and the title of a movie
#' @top_rating min rating to consider a movie a top movie for a user (inclusive)
#' @param returns a data.frame with the genres of top rated movies by the user.
test_user_selected = as(names(as(test_user_selected, 'list')), 'matrix') # Ugly code is beautiful too.
Movie_Genre$item = Movie_Genre$title
user_top_genres <- MovieLenseData %>%
filter(user %in% test_user_selected) %>%
filter(rating >= top_rating) %>%
left_join(Movie_Genre, by = "item") %>%
group_by(user, genre) %>%
summarise(n = n()) %>%
mutate(percent = 100 *n/sum(n))
user_top_genres$TopGenres <- user_top_genres$percent
#select(user, genre, n)
return (user_top_genres)
}fav_genres = fav_genre_of_users(test_user_selected, MovieLense_df, Movie_Genre)## `summarise()` has grouped output by 'user'. You can override using the `.groups` argument.ggplot(fav_genres, aes(x = user, y = percent, fill = genre)) +
geom_col() + labs(title = "Genre of highly rated Movies per User")
#scale_y_continuous(labels = percentage)Beschreibung
Auf der X-Achse sehen wir die ID der User und auf der Y-Achse die Verteilung der Genres in Prozenten. Hier sehen wir auch, wie unterschiedlch der Geschmack der User ist; es gibt wohl keine zwei User, welche die gleiche Verteilung der Genres haben.
- Vergleiche pro Kunde Top-Empfehlungen und Top-Filmen nach Genres
Beschreiben Wie oben geschrieben, schauen wir uns mehrere Modelle an und von denen die Genreverteilung der TopN-Listen an.
all_top_n_genres <- fav_genres %>%
full_join(IBCF_top_genre, by=c('user', 'genre')) %>%
full_join(UBCF_cos_top_genre, by=c('user', 'genre')) %>%
full_join(UBCF_jacc_top_n_genre, by=c('user', 'genre')) %>%
full_join(SVD_5_top_n_genre, by=c('user', 'genre')) %>%
full_join(SVD_10_top_n_genre, by=c('user', 'genre')) %>%
select_at(vars(-ends_with(".y"))) %>%
select_at(vars(-ends_with(".x")))
all_top_n_genres[is.na(all_top_n_genres)] = 0all_top_n_genres_melted = melt(all_top_n_genres, id.vars = c("user", "genre"), measure.vars = c("TopGenres", "IBCFCos", "UBCFCos", "UBCFJacc", "SVD5", "SVD10"))all_top_n_genres_meltedall_top_n_genres_melted_u201 <- all_top_n_genres_melted %>%
filter(user==201)
ggplot(all_top_n_genres_melted_u201, aes(x = variable, y = value, fill = genre)) +
geom_col() + labs(title = "Genre distribution of Top@N list of User 201") 
#scale_y_continuous(labels = percentage)Beschreibung
Oben sehen wir die Genreverteilung des Users 201 an. Auf die X-Achse sehen wir die Modelle und auf der Y-Achse die Verteilung der Genre von TopN-Listen. Es fällt auf, dass die Verteilung pro Modell sehr unterschiedlich ist.
all_top_n_genres_melted_u275 <- all_top_n_genres_melted %>%
filter(user==275)
ggplot(all_top_n_genres_melted_u275, aes(x = variable, y = value, fill = genre)) +
geom_col() + labs(title = "Genre distribution of Top@N list of User 275")
#scale_y_continuous(labels = percentage)Beschreibung
Oben sehen wir die Genreverteilung des Users 275 an. Auf die X-Achse sehen wir die Modelle und auf der Y-Achse die Verteilung der Genre von TopN-Listen. Es fällt auf, dass die Verteilung pro Modell sehr unterschiedlich ist.
cols = colnames(all_top_n_genres)[c(4:8)]
df <- data.frame(matrix(ncol = length(cols), nrow = 1))
colnames(df) <- colscalc_genre_err <- function(all_top_n_genres, cols){
#' @all_top_n_genres dataframe containing the top genres from top rated movies of users and predictions done by different models.
#' @cols Column names with the genre distributions of predictions.
#' @param returns a data.frame with the absolute error of genre difference between the user rated movies and the predicted movies.
df <- data.frame(matrix(ncol = length(cols), nrow = 1))
colnames(df) <- cols
top_genres <- all_top_n_genres$TopGenres
for (col in cols){
df_tmp = sum(abs(top_genres - all_top_n_genres[,col]) / length(top_genres))
df[1, col] <- df_tmp
}
return (df)
}all_top_n_genresgenre_error = calc_genre_err(all_top_n_genres, colnames(all_top_n_genres)[c(4:8)])5.Definiere eine Qualitätsmetrik für Top-N Listen und teste sie. Beschreibung Als Qualitätsmetrik definieren wir den MAE der TopN Genreverteilung, da wir gesehen haben, wie stark diese variert pro Modell.
Wir nehmen also den absoluten Fehler der prozentualen Verteilung pro genre pro user, summieren diesen und teilen diese durch die Anzahl der TopN-Empfehlungen (Anzahl User in den TopN-Empfehlungen * N (von TopN)). Wir können nicht genau den MAPE nehmen, da die Verteilung der Genres oft 0 sein kann. Somit wäre dies eine Division durch Null. Der Wert ansich ist also nicht so interpretierbar wie der MAPE, eignet sich aber um verschiedene Modelle zu vergleichen.
ggplot(melt(genre_error), aes(x = variable, y = value, fill = variable)) +
geom_col() + labs(title = "Error of Top@N genre distribution of different Models")## No id variables; using all as measure variables
#scale_y_continuous(labels = percentage)Beschreibung
Hier sehen wir auch, dass SVD5 sehr gut abschneideted, wie auch bei Recall, Precision, Coverage und Novelty. Wir würden für unseren Recommender also SVD5 benutzen.